Shareware Overload Trio 2

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir42 / c7105.zip / FILE.TPX < prev next >

Wrap

Text File | 1994-03-02 | 22KB | 373 lines

#!┌───────────────────────────┤Template Segment├───────────┬─────────────────┐ #!│ FILE.TPX │Version: 3007.105│ #!├───────────────────────────────┤Contents├───────────────┴─────────────────┤ #!│Structure Type Description │ #!│──────────────────── ───────── ─────────────────────────────────────────│ #!│File PROCEDURE Select a file from a directory listing │ #!│SetFileSymbols GROUP Sets Code Generation Symbols │ #!│SetFileErrors GROUP Generates ?Cancel Button Missing Warning │ #!├───────────────────────────────┤Comments├─────────────────────────────────┤ #!│Version Comments │ #!│──────── ────────────────────────────────────────────────────────────────│ #!│3007.000 Release of CDD3 version 3007 templates │ #!│3007.100 Repaired File Template │ #!│3007.103 Repaired File Template │ #!│3007.104 Repaired File Template │ #!│3007.105 Repaired File Template │ #!└──────────────────────────────────────────────────────────────────────────┘ #! #PROCEDURE(File,'Select a file from a directory listing'),SCREEN #! #!┌──────────────────────────┤Procedure Template├──────────┬─────────────────┐ #!│ File │Version: 3007.105│ #!├──────────────────────────────┤Description├─────────────┴─────────────────┤ #!│ The File template creates a procedure to allow a user to select a file. │ #!│ The file name with its full path will be saved in the variable entered │ #!│ at the 'Filename Variable' prompt. If this field is left blank the │ #!│ default of GLO:Filespec is used. (GLO:Filespec has been entered in │ #!│ Clarion's Default Application file for your convenience. It will be │ #!│ Smart-linked out of your final .EXE if not used.) │ #!│ │ #!│ If a Next Procedure is requested (ie: a procedure created with the View │ #!│ template) it will be called just prior to returning to the calling │ #!│ procedure. │ #!├───────────────────────────────┤Comments├─────────────────────────────────┤ #!│Version Comments │ #!│──────── ────────────────────────────────────────────────────────────────│ #!│3007.000 Release of CDD3 version 3007 templates │ #!│3007.100 In FillQueues ROUTINE, the call to SELECT(?FileList,1) was │ #!│ being made even if ?FileList was not defined. │ #!│3007.103 In ProcedureReturn ROUTINE, the call to SETPATH needed to have │ #!│ the trailing "\" stripped off of the directory path. │ #!│3007.104 In ProcedureReturn ROUTINE, the call to SETPATH was missing a │ #!│ trailing parentheses to close the setpath statement. │ #!│3007.105 In ProcedureReturn ROUTINE, the call to SETPATH was removing the│ #!│ trailing backslash on a set to the root directory. │ #!│ Repaired typographical error in comments (begining) │ #!│ Replaced RETURNs in FillQueues ROUTINE with DO ProcedureReturn │ #!└──────────────────────────────────────────────────────────────────────────┘ #! #PROTOTYPE('') #! No special prototype #INSERT(%StandardHeader) #! Procedure Comment Block #MAP('GETDIR.INC') #! Include Procs in MAP #DISPLAY(' ') #! Blank Line on Props Scrn #PROMPT('Filename &Variable',FIELD),%SaveFilenameVar #PROMPT('Initial Directory',@S30),%StartDir #PROMPT('Beginning File Mask',@S12),%StartMask #PROMPT('Next Procedure',PROCEDURE),%NextProcedure #PROMPT('Reselect Upon Return',CHECK),%AllowReselect #PROMPT('Blank Name On Cancel',CHECK),%ClearOnCancel #PROMPT('Allow Drive Searches',CHECK),%AllowDriveSearch #INSERT(%SetFileSymbols) #! Set Generation Flags #INSERT(%SetFileErrors) #! Warn Developer, if needed %Procedure PROCEDURE #<!%ProcedureDescription %LocalData #! Declare Local Data %ScreenStructure #! Declare Screen Structure DirString CSTRING(64) #<! Used for Directory to search SaveDir LIKE(DirString) #<! Used to hold beginning path SaveSelect LONG #<! Used to hold selected field DirInfo GROUP #<! Necessary DOS file group BYTE,DIM(21) #<! Used by findfirst Attrib BYTE #<! Attribute in DOS format DosTime SHORT #<! Time in DOS format DosDate SHORT #<! Date in DOS format Filesize LONG #<! Size in BYTES FileName CSTRING(13) #<! File name END #<! End GROUP #IF(%AllowDriveSearch) #! IF allowing to search drives DriveNumber USHORT #<! Used for Drive search CheckReady STRING(3) #<! Used to check if Drive is ready #ENDIF #! END (IF allowing...) #EMBED('Data Section') #! Embedded Source Code CODE #<! Begin Processing Code #EMBED('Setup Procedure') #! Embedded Source Code OPEN(%Screen) #<! Open the screen #EMBED('Setup Screen') #! Embedded Source Code #IF(%StartMask) #! IF Initial File Mask FileMask = '%StartMask' #<!Set the begining file mask #ELSE FileMask = '*.*' !Set the beginning file mask #ENDIF SaveDir = PATH() !Save the Starting Directory IF SUB(SaveDir,LEN(CLIP(SaveDir)),1) <> '\' ! Last character not backslash? SaveDir = CLIP(SaveDir) & '\' ! Add the trailing '\' END #IF(%StartDir) Directory = UPPER(%StartDir) #<!Change to the requested SETPATH(Directory) ! Starting directory Directory = PATH() ! Reread the current path IF SUB(Directory,LEN(CLIP(Directory)),1) <> '\' ! Last character not backslash? Directory = CLIP(Directory) & '\' ! Add the trailing '\' for display END #ELSE Directory = SaveDir !Set to the Current Directory #ENDIF DO FillQueues !Fill the screen queues LOOP !Main ACCEPT loop #INSERT(%GenerateFormulas) #EMBED('Top of Accept Loop') #! Embedded Source Code CASE SELECTED() #<! Jump to field setup routine #INSERT(%ScreenSetupRoutines) END #<! End CASE ACCEPT ! ACCEPT keyboard input #INSERT(%HotKeyRoutines) CASE FIELD() ! Jump to field edit routine #FOR(%ScreenField) #IF(%ScreenField = '?FileMask') OF ?FileMask ! Completed file mask field #IF(%ScreenFieldEdit) %ScreenFieldEdit #<! File mask edit routine #ENDIF IF REFER() ! If something was entered Do FillQueues ! Fill queues with new mask END ! End IF #ELSIF(%ScreenField = '?FileList') OF ?FileList ! FileList field edit GET(FileQueue,CHOICE()) ! Get selected file entry #IF(%ScreenFieldEdit) %ScreenFieldEdit #<! File list edit routine #ENDIF IF KEYCODE() = MouseLeft2 OR | ! On mouse double click KEYCODE() = EnterKey ! Or the Enter Key SELECT(?OK) ! Select the OK button and PRESS(EnterKey) ! Press Enter to complete END ! End IF #ELSIF(%ScreenField = '?DirList') OF ?DirList ! Directory list field edit #IF(%ScreenFieldEdit) %ScreenFieldEdit #<! Directory edit routine #ENDIF IF SELECTED() = ?DirList ! If staying on this field IF KEYCODE() = MouseLeft2 OR | ! On mouse double click KEYCODE() = EnterKey ! or the Enter Key GET(DirQueue,CHOICE()) ! Get the selected entry #IF(%AllowDriveSearch) IF LEN(CLIP(DirLine)) = 5 AND | ! Are we looking at a drive? SUB(DirLine,1,2) = '[-' AND | SUB(DirLine,4,2) = '-]' AND | SUB(DirLine,3,1) >= 'A' AND | SUB(DirLine,3,1) <= 'Z' CheckReady = SUB(DirLine,3,1) & ':' ! Specify drive letter designation IF STATUS(CheckReady) = 0 ! If drive not ready CYCLE ! Don't change to it END Directory = CLIP(CheckReady) ! Assign drive letter as new directory ELSE Directory = CLIP(Directory) & DirLine ! Create a new directory string END #ELSE Directory = CLIP(Directory) & DirLine ! Create a new directory string #ENDIF IF SUB(Directory,LEN(CLIP(Directory)),1) = '\' ! Last character a backslash? Directory = SUB(Directory,1,LEN(CLIP(Directory))-1) ! Get rid of it before SETPATH END SETPATH(Directory) ! Set to current directory Directory = PATH() ! Reread the current directory IF SUB(Directory,LEN(CLIP(Directory)),1) <> '\' ! Last character not backslash? Directory = CLIP(Directory) & '\' ! Add the trailing '\' for display END Do FillQueues ! Fill the screen queues END ! End IF END ! End IF #ELSIF(UPPER(%ScreenField) = '?OK') OF ?Ok ! Ok button field Edit #IF(%ScreenFieldEdit) %ScreenFieldEdit #<! OK button edit routine #ENDIF IF FileLine = ' NO MATCH ' ! If no FileName selected #IF(%DirQueueExists) SELECT(?DirList) ! Select directory list #ELSE SELECT(?Cancel) ! Select cancel button #ENDIF CYCLE ! Cycle to ACCEPT. END ! End IF %SaveFilenameVar = CLIP(Directory) & FileLine #<! Save the Filename #IF(%NextProcedure) SETPATH(SaveDir) ! Return to starting path #IF(%DirQueueExists) FREE(DirQueue) ! Free the DirQueue memory #ENDIF FREE(FileQueue) ! Free the FileQueue memory %NextProcedure #<! Call the Next procedure #IF(%AllowReselect) DO FillQueues ! Fill the screen queues SELECT(?FileList) ! Select the file list CYCLE ! Return to ACCEPT input #ELSE DO ProcedureReturn #<! And leave the Procedure #ENDIF #ELSE DO ProcedureReturn #<! And leave the Procedure #ENDIF #ELSIF(%ScreenField = '?Cancel') OF ?Cancel ! Cancel button field Edit #IF(%ScreenFieldEdit) %ScreenFieldEdit #<! Cancel button edit routine #ENDIF SETPATH(SaveDir) ! Return to starting path #IF(%DirQueueExists) FREE(DirQueue) ! Free the DirQueue memory #ENDIF FREE(FileQueue) ! Free the FileQueue memory #IF(%ClearOnCancel) CLEAR(%SaveFilenameVar) #<! Clear the filename variable #ENDIF DO ProcedureReturn #<! And leave the Procedure #ELSIF(%ScreenFieldEdit) #! OF %ScreenField #<! Completed %ScreenField %ScreenFieldEdit #<! %ScreenField edit routine #ENDIF #! #ENDFOR #! #INSERT(%PulldownEditRoutines) #! END #<! End CASE FIELD() END #<! End LOOP DO ProcedureReturn #<! And leave the Procedure !───────────────────────────────────────────────────────────────────────────── ProcedureReturn ROUTINE #<! return from the PROC IF LEN(CLIP(SaveDir)) > 3 ! If not on a root dir SETPATH(SUB(SaveDir,1,LEN(CLIP(SaveDir))-1)) ! Return to starting path END ! END (IF not on a root dir) #IF(%DirQueueExists) FREE(DirQueue) !Free the DirQueue memory #ENDIF FREE(FileQueue) !Free the FileQueue memory DO EndOfProcedureEmbed #<! Process the final EMBED RETURN #<! END exit the PROC !───────────────────────────────────────────────────────────────────────────── EndOfProcedureEmbed ROUTINE #<! Process the final EMBED #EMBED('End of Procedure') #! Embedded Source Code !───────────────────────────────────────────────────────────────────────────── #EMBED('Custom Routines') #! Embedded Source Code !───────────────────────────────────────────────────────────────────────────── FillQueues ROUTINE SaveSelect = SELECTED() !Save the current selected field FREE(FileQueue) !Free the FileQueue #IF(%FileListExists) SELECT(?FileList,1) !Reset file list box #ENDIF #IF(%DirQueueExists) FREE(DirQueue) !Free the DirQueue SELECT(?DirList,1) !Reset Dir List box DirString = CLIP(Directory) & '*.*' !Set the subdirectory mask IF NOT LEN(CLIP(DirString)) = 6 !If not in the root directory DirLine = '..\' ! Make prior directory entry ADD(DirQueue) ! Add to the DirQueue END !End IF IF FindFirst(DirString,DirInfo,FA_DIREC) <> 0 !If unexpected error DO ProcedureReturn ! END !End IF LOOP !While entries found IF FileName = '.' OR FileName = '..' ! If the dot entries IF FindNext(DirInfo) <> 0 ! Get the next entry BREAK ! Break if unexpected error END ! End IF CYCLE ! Return to dot entry check END ! End IF IF BAND(ATTRIB,10H) ! If a subdirectory is found DirLine = FileName ! Fill the queue field ADD(DirQueue) ! Add to the DirQueue IF ERRORCODE() THEN BREAK. ! Break if unexpected error END ! End IF IF FindNext(DirInfo) <> 0 ! Get the next entry BREAK ! Break if unexpected error END ! End IF END !End LOOP SORT(DirQueue,+DirLine) !Sort the directory listing #IF(%AllowDriveSearch) LOOP DriveNumber = 1 TO 26 !Loop through drive numbers IF IsAValidDrive(DriveNumber) !Validate drive number DirLine = '[-' & CLIP(CHR(DriveNumber-1+VAL('A'))) & '-]' !Format drive letter ADD(DirQueue) ! Add to the DirQueue END END #ENDIF #ENDIF FileLine = 'Searching...' !Search message ADD(FileQueue) !Add to the FileQueue DISPLAY !Display new directory and message FREE(FileQueue) !Free the FileQueue DirString=CLIP(Directory) & FileMask !Set the file mask IF FindFirst(DirString,DirInfo,FA_NORMAL) <> 0 !If no matching files found FileLine = ' NO MATCH ' ! Fill queue with message ADD(FileQueue) ! Add to the FileQueue Else !Else matching file found LOOP ! While entries are found IF BAND(ATTRIB,10H) = 0 ! If entry is a file FileLine = FileName ! Fill the queue field and ADD(FileQueue) ! Add to the FileQueue IF ERRORCODE() THEN BREAK. ! Break if unexpected error END ! End IF IF FindNext(DirInfo) <> 0 ! Get the next entry BREAK ! Break if unexpected error END ! End IF END ! End LOOP END !End IF SORT(FileQueue,+FileLine) !Sort the file listing DISPLAY !Display the new lists SELECT(SaveSelect) !Reselect the previous selected field #!*************************************************************************** #GROUP(%SetFileSymbols) #! #!┌────────────────────────────┤Template Group├────────────┬─────────────────┐ #!│ %SetFileSymbols │Version: 3007.000│ #!├──────────────────────────────┤Description├─────────────┴─────────────────┤ #!│Purpose: To setup symbols for generation of a procedure with the │ #!│ File template. │ #!│Called From: PROCEDURE: File │ #!│Assumptions: None │ #!│Inserts: None │ #!│Symbols Set: None │ #!│Notes: None │ #!└──────────────────────────────────────────────────────────────────────────┘ #! #IF(%SaveFilenameVar = %Null) #SET(%SaveFilenameVar, 'GLO:FileSpec') #ENDIF #SET(%DirQueueExists,%Null) #SET(%FileMaskExists,%Null) #SET(%FileListExists,%Null) #SET(%DirectoryExists,%Null) #SET(%FileOkExists,%Null) #SET(%FileCancelExists,%Null) #FOR(%ScreenField) #IF(UPPER(%ScreenField) = '?DIRLIST') #SET(%DirQueueExists,'YES') #ELSIF(UPPER(%ScreenField) = '?FILEMASK') #SET(%FileMaskExists,'YES') #ELSIF(UPPER(%ScreenField) = '?FILELIST') #SET(%FileListExists,'YES') #ELSIF(UPPER(%ScreenField) = '?DIRECTORY') #SET(%DirectoryExists,'YES') #ELSIF(UPPER(%ScreenField) = '?OK') #SET(%FileOkExists,'YES') #ELSIF(UPPER(%ScreenField) = '?CANCEL') #SET(%FileCancelExists,'YES') #ENDIF #ENDFOR #!*************************************************************************** #GROUP(%SetFileErrors) #! #!┌────────────────────────────┤Template Group├────────────┬─────────────────┐ #!│ %SetFileErrors │Version: 3007.000│ #!├──────────────────────────────┤Description├─────────────┴─────────────────┤ #!│Purpose: To warn the developer of any template errors │ #!│Called From: PROCEDURE: File │ #!│Assumptions: None │ #!│Inserts: None │ #!│Symbols Set: None │ #!│Notes: None │ #!└──────────────────────────────────────────────────────────────────────────┘ #! #IF(%FileCancelExists <> 'YES') #SET(%ErrorMessage,(%Procedure & ' WARNING:')) #ERROR(%ErrorMessage) #SET(%ErrorMessage,' ?Cancel button is not found in the screen structure,') #ERROR(%ErrorMessage) #SET(%ErrorMessage,' Exit code may not have been generated.') #ERROR(%ErrorMessage) #SET(%ErrorMessage,%Null) #ERROR(%ErrorMessage) #ENDIF #CHAIN('Screen.tpx')